home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / akcl1615.lha / lsp / profile.lsp < prev    next >
Lisp/Scheme  |  1988-10-20  |  4KB  |  111 lines
  1.  
  2. (in-package 'si)
  3. (use-package "SLOOP")
  4.  
  5. ;; Sample Usage:
  6. ;;    (si::set-up-profile 1000000) (si::prof 0 90)
  7. ;;     run program
  8. ;;    (si::display-prof)
  9. ;;    (si::clear)
  10. ;;    profile can be stopped with (si::prof 0 0) and restarted with 
  11. ;;start-address will correspond to the beginning of the profile array, and
  12. ;;the scale will mean that 256 bytes of code correspond to scale bytes in the
  13. ;;profile array.
  14. ;;Thus if the profile array is 1,000,000  bytes long and the code segment is 
  15. ;;5 megabytes long you can profile the whole thing using a scale of 50
  16. ;;Note that long runs may result in overflow, and so an understating of the
  17. ;;time in a function.  With a scale of 128 it takes 6,000,000 times through 
  18. ;;a loop to overflow the sampling in one part of the code.
  19.  
  20.  
  21.  
  22. ;(defun sort-funs (package)
  23. ;  (sloop for v in-package package with tem
  24. ;     when (and (fboundp v) (compiled-function-p
  25. ;                (setq tem (symbol-function v))))
  26. ;     collect (cons (function-start v) v)  into all
  27. ;     finally (loop-return (sort all #'(lambda (x y)
  28. ;                       (< (the fixnum (car x))
  29. ;                      (the fixnum (car y))))))))
  30. (defvar si::*profile-array*
  31.               (make-array 20000 :element-type 'string-char
  32.                   :static t
  33.                   :initial-element
  34.                   (code-char 0)))
  35.  
  36. (defun create-profile-array (&optional (n 100000))
  37.   (if *profile-array* (profile 0 0))
  38.   (setq *profile-array*          (make-array n :element-type 'string-char
  39.                   :static t
  40.                   :initial-element
  41.                   (code-char 0)))
  42.    n
  43.   )
  44.  
  45.  
  46. (defvar *current-profile* nil)
  47.  
  48. (defun pr (&optional n)
  49.   (sloop
  50.    with ar = si::*profile-array* declare (string ar)
  51.    for i below (if n (min n (array-total-size ar))   (array-total-size ar))
  52.    
  53.    do 
  54.    (cond ((not (= 0 i))(if (= 0 (mod i 20)) (terpri))))
  55.    (princ (char-code (aref ar i))) (princ " "))
  56.   (values))
  57.  
  58. (defun fprofile(fun &optional (fract 1000) offset)
  59.   (setq *current-profile* (list  (+ (function-start (symbol-function fun))
  60.                     (or offset 0))
  61.                  fract))
  62.   (apply 'profile  *current-profile* ))
  63.  
  64. ;(defun foo (n) (sloop for i below n do nil))
  65.  
  66. ;;problem: the counter will wrap around at 256, so that it really is not valid
  67. ;;for long runs if the functions are heavily used.  This means that
  68. ;;Remove all previous ticks from the profile array.
  69.  
  70. (defun clear-profile () (sloop  with ar = *profile-array* 
  71.             declare (string ar)
  72.                         for i below (array-total-size ar)
  73.             do (setf (aref  ar i) (code-char 0))))
  74.  
  75.  
  76. (defun prof-offset (addr) (* (/ (float (cadr *current-profile*)) #x10000)
  77.                     (- addr (car *current-profile*))))
  78.  
  79. (defun prof (a b)
  80.   (setf *current-profile* (list a b))
  81.   (profile a b))
  82.  
  83. (defun display-prof()
  84.    (profile 0 0)
  85.    (apply 'display-profile *current-profile*)
  86.    (apply 'profile *current-profile*))
  87.  
  88.  
  89. (defun set-up-profile (&optional (array-size 100000)(max-funs 6000)
  90. ;             (name "saved_kcl")(dir *system-directory*)&aux sym
  91.              )
  92. ;  (compiler::safe-system  (format nil "(cd ~a ; rsym ~a \"#sym\")" dir name))
  93. ;  (or (probe-file (setq sym  (format nil "~a#sym" dir))) (error "could not find ~a" sym))
  94. ;  (read-externals sym)
  95.   (set-up-combined max-funs)
  96.   (unless (and *profile-array*
  97.            (>= (array-total-size *profile-array*) array-size))
  98.       (print "making new array")
  99.       (setq *profile-array*  (make-array array-size
  100.                          :element-type 'string-char
  101.                          :static t
  102.                          :initial-element
  103.                          (code-char 0))))
  104.   (format t "~%Loaded c and other function addresses~
  105.    ~%Using profile-array length ~a ~
  106.     ~%Use (si::prof 0 90) to start and (prof 0 0) to stop:~
  107.     ~%This starts monitoring at address 0 ~
  108.     ~%thru byte (256/90)*(length *profile-array*)~
  109.     ~%(si::display-prof) displays the results" (length *profile-array*)))
  110.   
  111.